home *** CD-ROM | disk | FTP | other *** search
/ Celestin Apprentice 4 / Apprentice-Release4.iso / Languages / Mops 2.7 / Mops ƒ / Base < prev    next >
Encoding:
Text File  |  1995-10-09  |  12.7 KB  |  511 lines  |  [TEXT/MSET]
  1. \ Sept 92 mrh    New words etc. moving closer to ANSI standard
  2. \ Jul  93 mrh    Select{  removed - replaced by Select[ in caseMod
  3.  
  4. false    value    ECHO?        \ echo load to screen?
  5.  
  6. cr .( loading Base...)
  7.  
  8. \ (* ... *) defines a multi-line comment, which can be very useful.  Many
  9. \ Pascal compilers use these symbols - I thought it better not to use
  10. \ the C-style /* ... */  since */ already has a meaning.
  11. \ A useful improvement to the typical Pascal implementation is to keep a
  12. \ level count so that this kind of comment can be nested.
  13.  
  14. : (*
  15.     1                            \ initial level count
  16.     BEGIN
  17.         Mword  count  2dup
  18.         " (*"  s=
  19.         IF    2drop  1 +            \ increment level count
  20.         ELSE
  21.             " *)"  s=
  22.             IF  1 -                \ decrement level count
  23.                 ?dup  0EXIT        \ and if zero, we're done
  24.             THEN
  25.         THEN
  26.     AGAIN  ;        immediate
  27.  
  28.  
  29. \ We redefine a few useful words to take advantage of our optimization.
  30.  
  31. : 1+    state IF 1 postpone literal  postpone +  ELSE  1 +  THEN  ;    immediate
  32. : 2+    state IF 2 postpone literal  postpone +  ELSE  2 +  THEN  ;    immediate
  33. : 3+    state IF 3 postpone literal  postpone +  ELSE  3 +  THEN  ; immediate
  34. : 4+    state IF 4 postpone literal  postpone +  ELSE  4 +  THEN  ; immediate
  35.  
  36. : 1-    state IF 1 postpone literal  postpone -  ELSE  1 -  THEN  ;    immediate
  37. : 2-    state IF 2 postpone literal  postpone -  ELSE  2 -  THEN  ;    immediate
  38. : 3-    state IF 3 postpone literal  postpone -  ELSE  3 -  THEN  ;    immediate
  39. : 4-    state IF 4 postpone literal  postpone -  ELSE  4 -  THEN  ;    immediate
  40.  
  41. : 2*    state IF 1 postpone literal  postpone << ELSE  1 << THEN  ;    immediate
  42. : 2/    state IF 1 postpone literal  postpone a>> ELSE 1 a>> THEN ;    immediate
  43. : 4*    state IF 2 postpone literal  postpone << ELSE  2 << THEN  ;    immediate
  44. : 4/    state IF 2 postpone literal  postpone a>> ELSE 2 a>> THEN ;    immediate
  45.  
  46. \ ANSI words
  47.  
  48. : CELL+    state IF  postpone 4+  else  4 +  THEN  ;    immediate
  49. : CELL-    state IF  postpone 4-  else  4 -  THEN  ;    immediate
  50. : CELLS    state IF  2 postpone literal  postpone <<  ELSE    2 <<  THEN  ;  immediate
  51. : CHAR+    state IF  postpone 1+  else  1 +  THEN  ;    immediate
  52. : CHARS    ;                        immediate
  53.  
  54. 4    constant    1CELL            \ Not ANSI, but useful
  55.  
  56.  
  57. : RECURSE        curr-def  compile,  ;            immediate
  58.  
  59. : SAVE-INPUT
  60.     src-start  src-len  >in @  source-id  4  ;
  61.  
  62. : RESTORE-INPUT
  63.     dup 4 <>  IF  true  EXIT  THEN
  64.     drop
  65.     -> source-id  >in !  -> src-len  -> src-start  false  ;
  66.  
  67.  
  68. \        =========================
  69.  
  70. \ These can be useful:
  71.  
  72. : UMAX    2dup u> IF drop ELSE nip THEN  ;
  73. : UMIN    2dup u< IF drop ELSE nip THEN  ;
  74.  
  75.  
  76. \ .H and U.H print a number in hex, signed and unsigned respectively.
  77.  
  78. : .H    base >r  hex   .  r> -> base  ;
  79. : U.H    base >r  hex  u.  r> -> base  ;
  80.  
  81.  
  82.     0    constant    Z
  83.  
  84. : NULLOSSTR        ['] z  ;
  85.  
  86.  
  87. : @WORD        \ ( -- addr )  Retrieves next blank-delimited word from input stream.
  88.     BL word  ;
  89.  
  90. : LIT        \ ( n -- )  A state-smart version of LITERAL.  Corresponds
  91.             \ to LITERAL in Fig-Forth or original Neon, whereas our
  92.             \ present LITERAL is Forth-83/ANSI.
  93.     state  IF  postpone literal  THEN  ;        immediate
  94.  
  95. : 0,  0 ,  ;        \ Compiles an empty cell
  96.  
  97. : @VAL    intrp1  ;    \ Compiles a number from input stream
  98.  
  99.  
  100. : 'TYPE        \ ( -- 4bytes )   OS type literal
  101.     pad 4 bl fill  @word count 4 min
  102.     pad swap cmove  pad @  postpone lit  ;    immediate
  103.  
  104. create BUF255  256 allot        \ buffer for string operations
  105.  
  106. : >STR255        \ ( addr len addr -- addr )
  107.                 \ Converts a string to a Str255 at addr
  108.     dup >r  place  r>  ;
  109.  
  110. : STR255    \ ( -- ^buf255 )
  111.     buf255 >str255  ;
  112.  
  113.  
  114. : $        \ State-smart HEX literal word
  115.     base >r
  116.     hex  Mword  number  postpone lit
  117.     r> -> base  ;            immediate
  118.  
  119.  
  120. : LITW        \ ( n -- )
  121.     $ 3D3C w,  w,  ;
  122.  
  123.  
  124. : W        intrp1  litw  ;        immediate
  125.  
  126.  
  127. (* Trap compilation.  When we're fully native on the PowerPC this will
  128.    become totally obsolete...
  129. *)
  130.  
  131.  
  132. : SAVA5        postpone doSavA5  ;
  133.  
  134. : RSTA5
  135.     $ CD4F w,            \    exg    a6,a7
  136.     $ 2A5F w,  ;        \    move.l    (a7)+,a5
  137.  
  138. : (TRAP$)    \ ( trap# -- )  Compiles a call to the given trap.
  139.     SavA5  w,  RstA5  ;
  140.  
  141. : TRAP$        \ ( --<trap#> )
  142.     base >r
  143.     hex  intrp1  (trap$)
  144.     r> -> base  ;        immediate
  145.  
  146.  
  147. : (FDOS$)        \ ( trap# -- )
  148.     $ 205E w,                \    move.l    (a6)+,a0    ; FCB pointer
  149.     SavA5  w,  RstA5
  150.     $ 48C0 w,                \    ext.l    d0    ; Result
  151.     $ 2D00 w,  ;            \    move.l    d0,-(a6)
  152.  
  153.  
  154. : FDOS$        \ ( --<trap#> )
  155.     base >r
  156.     hex  intrp1  (fdos$)
  157.     r> -> base  ;        immediate
  158.  
  159.  
  160. \                    ==================
  161.  
  162. \ Once we're compiling PPC code, we have to keep the code and data areas
  163. \  distinct.  DP points to the data area, so we now add CDP pointing to
  164. \  the code area.
  165.  
  166.     0    value    CDP
  167.  
  168. : code,        PPC? IF  CDP !   4 ++> CDP  ELSE  ,   THEN  ;
  169. : codeW,    PPC? IF  CDP w!  2 ++> CDP  ELSE  w,  THEN  ;
  170. : codeC,    PPC? IF  CDP c!  1 ++> CDP  ELsE  c,  THEN  ;
  171.  
  172. ' null  vect  PPC_HEADER
  173.  
  174.  
  175. \                    ==================
  176.  
  177.  
  178.  
  179. 0  value    ResRefNum
  180.  
  181. : OpenResFile        \ ( addr len -- )  Opens named resource file
  182.     >r >r word0 r> r> str255
  183.     trap$ a997  i->l                \ call OpenResFile
  184.     dup -> ResRefNum
  185.     -1 = abort" resource file open failed"  ;
  186.  
  187. : CloseResFile        \ ( -- )
  188.     ResRefnum  makeint  trap$ a99a  ;
  189.  
  190.  
  191. : OPENMR            \ Opens the Mops system resource file if necessary.
  192.     MRopen?  ?EXIT                    \ Do nothing if already open
  193.     instld?  ?EXIT                    \ or if this is an installed application
  194.     " mops.rsrc" OpenResFile
  195.     true -> MRopen?  ;
  196.  
  197.  
  198. : CHAR        @word 1+ c@  ;                \ ANSI - replaces ASCII
  199. : [CHAR]    @word 1+ c@  postpone literal  ;    immediate
  200.  
  201. : &            \ ( -- c )  A shorter state-smart version.
  202.     @word 1+ c@  postpone lit  ;        immediate
  203.  
  204.  
  205. : GETSTRING        \ ( resID -- addr len )  Get the string with resource ID
  206.     openMR
  207.     0 swap makeint  trap$ a9ba        \ call getString
  208.     dup if  @ count  else  0  then  ;
  209.  
  210.  
  211. : (TSTR)            \ ( id# -- )  Prints string with given resID.
  212.     getString type  ;
  213.  
  214. : X    ['] (tstr) -> tstr  ;        \ We can't do -> outside a defn till Args loaded
  215. x  forget x
  216.  
  217.  
  218. \ Our normal error action is to call DIE with an error number.  DIE calls
  219. \ SvErr to save the error info, then THROWs the error number.  If no error
  220. \ handler has been installed, or only handlers which don't want that number
  221. \ and re-THROW it, the default action for THROW occurs.  This calls DFLT-DIE.
  222.  
  223. : (DDIE)            \ ( n -- )
  224.     setFwind
  225.     +echo   0 -> (err#)        \ Clear error indicator from AppleEvents
  226.     dflt-err  ;                \ Display error info and abort
  227.  
  228. : x    ['] (ddie) -> dflt-die  ;
  229. x  forget x
  230.  
  231.  
  232. : ?ERROR        \ ( b -- )  Aborts and prints resource string if true.
  233.                 \ Usage:  ?error 999
  234.     postpone if
  235.     intrp1  ( get err# )  postpone literal   postpone die
  236.     postpone then  ;        immediate
  237.  
  238.  
  239. : TYPE#        \ Prints string for id# in stream
  240.     intrp1  postpone lit   postpone (tStr)  ;    immediate
  241.  
  242.  
  243. : (.RSTR)    \ ( -- )  print "Msg# ..." then string with given resID
  244.     ." Msg# " dup . ." : "  (tStr)  ;
  245.  
  246.  
  247. : MSG#        \  usage: " Msg# <number>"
  248.     intrp1  postpone lit  postpone (.rStr)  ;    immediate
  249.  
  250.  
  251. \        ============ Resources ===========
  252.  
  253.  
  254. : GETRES    \ ( type resID -- handle )
  255.     0 down makeint  trap$ a9a0  ;        \ call GetResource
  256.  
  257.  
  258. \ ( -- #cells)
  259.  
  260. : RDEPTH        rp0  rp@ - 4/ 2-  ;
  261.  
  262. : ?RDEPTH        rp@  sp0 20 + < ?error 116  ;    \ err if rtn stk about to
  263.                                                 \ collide with data stk
  264.  
  265.  
  266. \        ========== Type checking ===========
  267.  
  268. \ Sometimes we want to check that a non-object parameter to a word is of a 
  269. \ certain type.  We give it a unique type code and use TYPCHK.
  270.  
  271. : TYPCHK    <>  ?error 179  ;
  272.  
  273.  
  274. \        ========== Forward definitions ===========
  275.  
  276.  
  277. : X    setfWind +echo
  278.     cr ." From " r@ .id  2 spaces  r@ .h  cr  109 die  ;
  279.  
  280.  
  281. : FORWARD
  282.     colHdr
  283.     $ 487AFFFE  ,                \    pea   (start of this instrn)
  284.     ['] x  here  6 allot
  285.     (patch)  ;
  286.  
  287. : :F    301
  288.     here  '  (patch)  :noname  ;
  289.  
  290. : ;F    (;)  301 ?defn  ;        immediate
  291.  
  292.  
  293. forward    BLD        \ Used in CLASS.  Needs to be down here so we never
  294.                 \ refer to it with a short branch.  Kludge?
  295.  
  296. \ Commonly needed error words.  These are forward defined - the main
  297. \ application should provide a sensible definition, with a nice friendly
  298. \ alert box, to tell the user in a nice friendly way that things are up
  299. \ the creek.
  300.  
  301. forward    NOMEM        \ Call when (not if!) we run out of memory.
  302.  
  303. forward    I/O_ERR        \ ( err# -- )  Call when there's an I/O error.
  304.  
  305. : OK?        \ ( rc -- )  A useful word to use after an I/O op.
  306.     ?dup  0EXIT  I/O_err  ;
  307.  
  308.  
  309. \        ========= :PROC and ;PROC ============
  310.  
  311. : :PROC
  312.     colHdr  here  6 allot
  313.     ['] procEntry  swap  6  aligned_move
  314.     :noname  303  ;        immediate
  315.  
  316. : ;PROC        immediate
  317.     postpone procExit  (;)
  318.     303 ?defn  ;
  319.  
  320.  
  321. \     ======== Various utility words needed later =========
  322.  
  323. \ BECOME allows restarting at a given word, with all stacks
  324. \ empty.  This is necessary in menu handlers and other areas
  325. \ that could create indefinite nesting situations.
  326.  
  327. ' quit    vect    BECOMECFA
  328.  
  329. : BE    sp0 sp!  rp0 rp!  becomeCfa  quit  ;
  330.  
  331. : (BE)    -> becomeCfa be  ;
  332.  
  333.  
  334. : BECOME        \ Usage: Become newWord - compiles code to Be at runtime
  335.     state
  336.     IF        postpone [']  postpone (be)
  337.     ELSE    '  -> becomeCfa  be
  338.     THEN  ;            immediate
  339.  
  340.  
  341. : DATETIME
  342.     $ 20C  @  ;
  343.  
  344.  
  345. \        ============ Tables, lists etc. ===============
  346.  
  347. (*    With Mops 2.5 we're trying to be consistent with the way we delimit
  348.     various kinds of lists with { ... }.  No, we're not trying to copy C,
  349.     but let's at least follow the "principle of minimum astonishment"!
  350.     Thus, with words like xts{, we'll allow a variant "xts {" where you
  351.     can put a space before the "{".  This is very easy to implement, so
  352.     why not?
  353. *)
  354.  
  355. forward  {        immediate
  356.  
  357. : GOBBLE{        \ gobbles a "{" which must follow as a separate word.
  358.     '  ['] {  <>  ?error 113  ;        \ "{" expected
  359.  
  360. : )        123 die  ;    immediate        \ ") read when no list is current"
  361. : (})    123 die  ;    immediate        \ "unmatched }"
  362.  
  363. ' (})    vect    }                    \ } will mean different things in different
  364.                                     \  contexts.
  365.  
  366. : }OR)?        \ ( cfa -- cfa b )
  367.     dup  ['] }  =  over  ['] ) =  or  ;
  368.  
  369. (*
  370. : TABLE
  371.     <BUILDS        0 w,  here  112
  372.     DOES>        length  ;
  373.  
  374. : END_TABLE
  375.     112 ?pairs
  376.     here over -            \ table length (excluding length field)
  377.     swap 2- w!  ;        \ store in length field
  378. *)
  379.     0    value        CNT
  380.  
  381.  
  382. : (LITS)        \ stack compiled list of values starting at IP
  383.     w@(ip)  ( count )  dup  -> cnt
  384.     4* r> tuck +  dup >r  swap
  385.     do  i @abs  4 +loop
  386.     cnt  ;
  387.  
  388.  
  389. : XTS{            \ State-smart word to compile or stack a list
  390.                 \ of xts.  Pulls words from stream, until "}".
  391.     state IF   postpone (lits)  here  0 w,  THEN
  392.     0
  393.     BEGIN   '   }or)?
  394.     NWHILE   state IF  reloc,  else  swap  THEN  1+
  395.     REPEAT
  396.     drop   state IF  swap w!  THEN  ;        immediate
  397.  
  398. : CFAS{    postpone xts{  ;    immediate        \ Synonyms for compatibility
  399. : CFAS(    postpone xts{  ;    immediate
  400.  
  401. : XTS    gobble{  postpone xts{  ;        immediate
  402.  
  403.  
  404. : RESERVE        \ ( len -- )  Allot and clear.
  405.     here over erase allot  ;
  406.  
  407.  
  408. (* SCON defines a string constant.  Usage:
  409.  
  410.     scon    <name>    "a string"
  411.  
  412.   Runtime: ( -- addr len )
  413.  
  414.   Change from Neon: the first nonblank char after the name of the SCON
  415.   becomes the delimiter.  So " can be used as usual, but anything else can
  416.   be used instead, e.g.:
  417.  
  418.      scon    <name>    /this string contains " as non-delimiter/
  419. *)
  420.  
  421. : SCON
  422.     <BUILDS        bl skip-src+
  423.                 src-start >in @ + c@  ,dlm-str
  424.     DOES>        count  ;
  425.  
  426.  
  427. \ CASE should be used for non-contiguous or dynamically computed values.
  428. \ This is a modified Eaker/Duncan model.
  429. \ Our optimization strategy gives quite good code.
  430.  
  431. : CASE        ?comp  302  ;        immediate
  432.  
  433. : OF
  434.     postpone over  postpone =  postpone if
  435.     postpone drop  ;            immediate
  436.  
  437. : RANGEOF
  438.     postpone within?  postpone if
  439.     postpone drop  ;            immediate
  440.  
  441. : ENDOF
  442.     postpone else  ;            immediate
  443.  
  444. : ENDCASE        immediate
  445.     postpone drop
  446.     BEGIN  dup 302 =  NWHILE  >resolve  REPEAT  drop  ;
  447.  
  448. (* TYPE{ and ENUM{ (synonyms) define a Pascal/C-like enumerated type.
  449.    At this stage we don't give a name to the "type" as such, as we can't
  450.    do anything really sensible with it.  However later we can optionally
  451.    load the ENUM-TYPE class which is rather more Pascal-like.  But even
  452.    without that, the enumeration is very useful by itself.
  453. *)
  454.  
  455.     0    value    TYPECNT
  456.  
  457. ' null    vect    DO_ET        \ Hook for handling the ENUM-TYPE
  458.                             \ class when it's loaded
  459.                             
  460. : ENDLIST?        \ ( chr -- b )
  461.     latest n>count 1 =  down  c@ =  and
  462.     dup  IF  latest n>link  (forget)  THEN  ;
  463.  
  464.  
  465. : TYPE{
  466.     0 -> typeCnt                \ 1st value
  467.     BEGIN    typeCnt  constant  1 ++> typeCnt
  468.             & }  endlist?
  469.     UNTIL
  470.     do_ET  ;
  471.  
  472. : ENUM{        type{  ;            \ C fans might like this name better
  473. : ENUM        gobble{  type{  ;
  474.  
  475.                 \ note we can't allow "type { ..." since "type" has another
  476.                 \ meaning already.  But "enum { ..."  is OK.
  477.  
  478. type{  InMainDic  InOtherMod  InThisMod  }        \ Relocatable addr types
  479.  
  480.  
  481. \        ========== Error diagnostics ===========
  482.  
  483. \ We use special values for nil handles and nil pointers.  These are
  484. \ odd addresses in ROM, so that if we do a word or long access we will
  485. \ trap, and if we write a byte it at least won't go anywhere.
  486.  
  487.  
  488. : .RTN        \ ( addr -- )
  489.     cr ." From  $"  .h  4 spaces  ;
  490.  
  491. : RANGE_ERR    \ ( index range rtn-addr -- )
  492.     dup 1+ 0=  ?error 128            \ Spurious range error
  493.     .rtn
  494.     dup -1 <
  495.     IF        nip  ?error 130            \ Not an indexed class
  496.     ELSE    ." Range: " .  ."   Index: " .
  497.             true  ?error 129
  498.     THEN  ;
  499.  
  500.  
  501. \ If we do software mult and div (on a 68000 which only allows a 16-bit divisor or
  502. \ multiplicand) we also check for overflow and call ArithErr (vector) if ovfl occurs.  
  503. \ The appropriate err# is on the stack already, so here we just set ArithErr to Die.
  504. \ This can be redirected as needed.
  505.  
  506. : X    ['] range_err -> rngErr   ['] die  -> arithErr  ;
  507.  
  508. x   forget x
  509.  
  510. load Args
  511.